(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ") T) (LISPXPRIN1 (QUOTE 
"18-NOV-72  0:31:34") T) (LISPXTERPRI T))
(LISPXPRINT (QUOTE GROUPVARS) T)
(RPAQQ GROUPVARS ((FNS FIXUPGROUP FINDNEWGROUP FINDNEWGROUP1 FINDPERMS
POSSIMS CONNECTIVITY GROUPCOUNT FOUND? FINDGROUPEDGES IMAGE 
FINDGROUPNODES) (VARS)))
(DEFINEQ

(FIXUPGROUP
(LAMBDA (STRUC) (REPLACE (GROUP STRUC) (FINDNEWGROUP STRUC (
CLASSIFYNODES (PROG (X) (SETQ X (NODES STRUC)) (FOR NEW NL IN (CAR
(GROUP STRUC)) DO (SETQ X (DIFF X NL))) (RETURN X)) STRUC)))))

(FINDNEWGROUP
(LAMBDA (STRUC NEWORBITS) (PROG (NEWOBJ) (SETQ NEWOBJ (FOR NEW ORB
IN NEWORBITS XLIST FIRST (CAR (GROUP STRUC)) (REVERSE ORB))) (RETURN
(CONS NEWOBJ (FOR NEW P IN (FINDNEWGROUP1 STRUC NEWORBITS) WHEN (NOT
(EQUAL NEWOBJ (CDR P))) XLIST (CDR P)))))))

(FINDNEWGROUP1
(LAMBDA (STRUC NEWORBITS) (FOR NEW P IN (GROUP STRUC) NCONC FIRST
NIL (FINDPERMS (CAR NEWORBITS) NEWORBITS (CONS NIL P) (CONS NIL (CAR
(GROUP STRUC))) STRUC))))

(FINDPERMS
(LAMBDA (NODES CLASSES IMS MAPPED STRUC) (IF (NULL CLASSES) THEN (LIST
IMS) ELSEIF (NULL NODES) THEN (FINDPERMS (CADR CLASSES) (CDR CLASSES)
(CONS NIL IMS) (CONS NIL MAPPED) STRUC) ELSE (FOR NEW Y IN (POSSIMS
(CAR NODES) (CAR CLASSES) IMS MAPPED STRUC) NCONC FIRST NIL (FINDPERMS
(CDR NODES) CLASSES (CONS (CONS Y (CAR IMS)) (CDR IMS)) (CONS (CONS
(CAR NODES) (CAR MAPPED)) (CDR MAPPED)) STRUC)))))

(POSSIMS
(LAMBDA (X CLASS IMS MAPPED STRUC) (FOR NEW Y IN CLASS WHEN (NOT (MEMB
Y (CAR IMS))) WHEN (FOR NEW ML IN MAPPED AS NEW IL IN IMS FOR NEW
M IN ML AS NEW I IN IL AND (EQP (CONNECTIVITY Y I STRUC) (CONNECTIVITY
X M STRUC))) XLIST Y)))

(CONNECTIVITY
(LAMBDA (X Y STRUC) (FOR NEW Z IN (NBRS (FINDCTE X STRUC)) WHEN (EQP
Z Y) IPLUS 1)))

(GROUPCOUNT
(LAMBDA (L) (PROG NIL (SETQ L (GROUPBY (QUOTE CDR) (CLCREATE L)))
(RETURN (FOR NEW I := ((FOR NEW X IN L MAX (CAR X)) 1 -1) XLIST (
*CARLIST (LMASSOC I L NIL)))))))

(FOUND?
(LAMBDA (NODE GROUP) (FOR NEW NL IN (CAR GROUP) AS NEW N := (1 9999999)
DO (IF (MEMB NODE NL) THEN (RETURN (CONS N NL))))))

(FINDGROUPEDGES
(LAMBDA (EDGES STRUC) (PROG (G) (IF (NOT (FOR NEW EDGE IN EDGES AND
(AND (FOUND? (NODE1 EDGE) (GROUP STRUC)) (FOUND? (NODE2 EDGE) (GROUP
STRUC))))) THEN (FIXUPGROUP STRUC) ELSE NIL) (SETQ G (GROUP STRUC))
(RETURN (NPL OKPERMS = (LIST (CAR G)) REMPERMS = (FOR NEW P IN (CDR
G) XLIST (CHECKPERM ORIGPERM = P OBJ = EDGES POBJ = (FOR NEW EDGE
IN EDGES LIST (ORDPAIR (IMAGE (NODE1 EDGE) (CAR G) P) (IMAGE (NODE2
EDGE) (CAR G) P))))))))))

(IMAGE
(LAMBDA (NODE MAPPED IMAGES) (FOR NEW ML IN MAPPED AS NEW IL IN IMAGES
FOR NEW M IN ML AS NEW I IN IL WHEN (EQP NODE M) DO (RETURN I))))

(FINDGROUPNODES
(LAMBDA (OBJECTS STRUC) (PROG (N FOUND) L1 (SETQ FOUND (FOUND? (CAR
OBJECTS) (GROUP STRUC))) (IF (NOT FOUND) THEN (FIXUPGROUP STRUC) ELSE
(RETURN (NPL OKPERMS = (LIST (CAR (GROUP STRUC))) REMPERMS = (FOR
NEW P IN (CDR (GROUP STRUC)) XLIST (CHECKPERM ORIGPERM = P OBJ = (CDR
FOUND) POBJ = (CAR (NTH P (CAR FOUND)))))))) (GO L1))))
)
STOP